;;; -*- Mode:LISP; Package:SIM; Readtable:CL; Base:10 -*-

(defvar *local-symbols*)

; dest, s1, s2 could be:
;   (open 4)
;   (active 2)
;   (return 0)
;   (global 555)
;   (func vma)

; (alu dest <- s1 aluop s2)
; (jump condition target)
; (jump-xct-next condition target)
; (sim sim-halt)

(defprop halt ((%%i-halt 1)) sim-asm)

(defun assemble-inst (sym-inst)
  (when (eq (car sym-inst) 'vma-start-read)
    (setq sym-inst `(alu (func ,(car sym-inst)) <- ,(cadr sym-inst) setl (garbage))))
  (let ((func (get (car sym-inst) 'sim-asm-function)))
    (cond ((null func)
           (ferror nil "unknown form ~s" sym-inst))
          (t
           (funcall func sym-inst)))))

(defun parse-register-adr (inst clause reg-base reg-offset &aux load-time-stuff)
  (declare (values new-inst load-time-stuff))
  (let ((reg-base-field (eval reg-base))
        (reg-offset-field (eval reg-offset)))
    (ecase (car clause)
      (open
       (setq inst (dpb %i-base-open reg-base-field inst))
       (setq inst (dpb (cadr clause) reg-offset-field inst)))
      (active
       (setq inst (dpb %i-base-active reg-base-field inst))
       (setq inst (dpb (cadr clause) reg-offset-field inst)))
      (return
       (setq inst (dpb %i-base-return reg-base-field inst))
       (setq inst (dpb (cadr clause) reg-offset-field inst)))
      (garbage
       (setq inst (dpb %i-base-return reg-base-field inst))
       (setq inst (dpb -1 reg-offset-field inst)))
      (global
       (setq inst (dpb %i-base-global reg-base-field inst))
       (let ((val (eval (cadr clause))))
         (setq inst (dpb (ldb (byte 4 0) val) reg-offset-field inst))
         (when (and (not (zerop (ldb %%i-immediate inst)))
                    (not (= (ldb %%i-immediate inst) (ldb (byte 8 4) val))))
           (ferror nil "inconsistant globals"))
         (setq inst (dpb (ldb (byte 8 4) val) %%i-immediate inst))))
      (constant
       (setq inst (dpb %i-base-global reg-base-field inst))
       (setq load-time-stuff (append `(%%i-immediate (constant-frame ,(cadr clause))) load-time-stuff))
       (setq load-time-stuff (append `(,reg-offset (constant-offset ,(cadr clause))) load-time-stuff)))
      (func
       (setq inst (dpb %i-base-func reg-base-field inst))
       (let ((adr (get (cadr clause) 'sim-func)))
         (when (null adr)
           (ferror nil "unknown functional register ~s" (cadr clause)))
         (setq inst (dpb (eval adr) reg-offset-field inst))))
      )
    (values inst load-time-stuff)))

(defprop alu assemble-inst-alu sim-asm-function)
(defprop alu ((%%i-opcode %i-op-alu)) sim-asm)
(defprop no-op assemble-inst-alu sim-asm-function)
(defprop no-op ((%%i-dest-base 3)) sim-asm)
(defprop noop assemble-inst-alu sim-asm-function)
(defprop noop ((%%i-dest-base 3)) sim-asm)

(defprop add ((%%i-aluf lam:lam-alu-add)
              (%%i-uses-alu 1)) sim-asm)
(defprop set1 ((%%i-aluf lam:lam-alu-setm)) sim-asm)
(defprop set-source-1 ((%%i-aluf lam:lam-alu-setm)) sim-asm)
(defprop setl ((%%i-aluf lam:lam-alu-setm)) sim-asm)
(defprop setm ((%%i-aluf lam:lam-alu-setm)) sim-asm)
(defprop setz ((%%i-aluf lam:lam-alu-setz)) sim-asm)
(defprop m-a-1 ((%%i-aluf lam:lam-alu-m-a-1)
                (%%i-uses-alu 1)) sim-asm)
(defprop l-r-1 ((%%i-aluf lam:lam-alu-m-a-1)
                (%%i-uses-alu 1)) sim-asm)
(defprop sub ((%%i-aluf lam:lam-alu-sub)
              (%%i-uses-alu 1)) sim-asm)
(defprop or ((%%i-aluf lam:lam-alu-ior)
             (%%i-uses-alu 1)) sim-asm)
(defprop and ((%%i-aluf lam:lam-alu-and)
              (%%i-uses-alu 1)) sim-asm)
(defprop l+r+1 ((%%i-aluf lam:lam-alu-m+a+1)
                (%%i-uses-alu 1)) sim-asm)

(defprop <- t sim-asm)

(defprop vma %func-vma sim-func)
(defprop vma-start-write %func-vma-start-write sim-func)
(defprop vma-start-read %func-vma-start-read sim-func)
(defprop md %func-md sim-func)
(defprop return %func-return sim-func)
(defprop instruction-counter %func-instruction-counter sim-func)
(defun assemble-inst-alu (sym-inst)
  (let ((inst 0)
        (regs '((%%i-dest-base %%i-dest-offset)
                (%%i-src-1-base %%i-src-1-offset)
                (%%i-src-2-base %%i-src-2-offset)))
        load-time-stuff
        x)
    (dolist (clause sym-inst)
      (cond ((consp clause)
             (multiple-value-bind (new-inst load-stuff)
                 (parse-register-adr inst clause (caar regs) (cadar regs))
               (setq inst new-inst)
               (setq load-time-stuff (append load-time-stuff load-stuff)))
             (pop regs))
            ((setq x (get clause 'sim-asm))
             (when (consp x)
               (dolist (field x)
                 (setq inst (dpb (eval (cadr field)) (eval (car field)) inst)))))
            (t
             (ferror nil "unknown atom ~s" clause))))
    (cons inst load-time-stuff)))

(defprop store-immediate assemble-inst-immediate sim-asm-function)
(defprop store-immediate ((%%i-opcode %i-op-store-immediate)) sim-asm)
(defprop boxed ((%%i-unboxed-dest 0)) sim-asm)
(defprop unboxed ((%%i-unboxed-dest 1)) sim-asm)

(defun assemble-inst-immediate (sym-inst)
  (let ((inst 0) x load-time-stuff)
    (dolist (clause sym-inst)
      (cond ((consp clause)
             (multiple-value-bind (new-inst load-stuff)
                 (parse-register-adr inst clause '%%i-dest-base '%%i-dest-offset)
               (setq inst new-inst)
               (setq load-time-stuff (append load-time-stuff load-stuff))))
            ((setq x (get clause 'sim-asm))
             (when (consp x)
               (dolist (field x)
                 (setq inst (dpb (eval (cadr field)) (eval (car field)) inst)))))
            (t
             (ferror nil  "unknown atom ~s" clause))))
    (cons inst load-time-stuff)))

(defprop immediate-data assemble-inst-immediate-data sim-asm-function)
(defun assemble-inst-immediate-data (sym-inst)
  (cons 0 `(immediate-data ,(cadr sym-inst))))

(defprop jump assemble-inst-jump sim-asm-function)
(defprop jump ((%%i-opcode %i-op-jump)
               (%%i-noop-next-bit 1))
  sim-asm)
(defprop jump-xct-next assemble-inst-jump sim-asm-function)
(defprop jump-xct-next ((%%i-opcode %i-op-jump)) sim-asm)

(defprop always ((%%i-jump-cond %i-jump-cond-unc)) sim-asm)
(defprop less-than ((%%i-jump-cond %i-jump-cond-less-than)) sim-asm)
(defprop equal ((%%i-jump-cond %i-jump-cond-equal)) sim-asm)
(defprop not-equal ((%%i-jump-cond %i-jump-cond-not-equal)) sim-asm)
(defprop greater-than ((%%i-jump-cond %i-jump-cond-greater-than)) sim-asm)
(defprop greater-or-equal ((%%i-jump-cond %i-jump-cond-greater-or-equal)) sim-asm)
(defprop data-type-equal ((%%i-jump-cond %i-jump-cond-data-type-equal)) sim-asm)
(defprop data-type-not-equal ((%%i-jump-cond %i-jump-cond-data-type-not-equal)) sim-asm)

(defun assemble-inst-jump (sym-inst)
  (let ((inst 0) x load-time-stuff)
    (dolist (clause sym-inst)
      (cond ((consp clause)
             (ferror nil "??"))
            ((setq x (get clause 'sim-asm))
             (when (consp x)
               (dolist (field (get clause 'sim-asm))
                 (setq inst (dpb (eval (cadr field)) (eval (car field)) inst)))))
            ((numberp clause)
             (setq inst (dpb clause %%i-jump-adr inst)))
            ((assq clause *local-symbols*)
             (setq load-time-stuff (append `(%%i-jump-adr (local-jump-target ,clause)) load-time-stuff)))
            (t
             (setq load-time-stuff (append `(%%i-jump-adr (jump-target ,clause)) load-time-stuff)))))
    (cons inst load-time-stuff)))

(defun assemble-inst-generic (sym-inst)
  (let ((inst 0) x)
    (dolist (clause sym-inst)
      (cond ((consp clause)
             (ferror nil "??"))
            ((setq x (get clause 'sim-asm))
             (when (consp x)
               (dolist (field (get clause 'sim-asm))
                 (setq inst (dpb (eval (cadr field)) (eval (car field)) inst)))))
            (t
             (ferror nil "unknnown atom ~s" clause))))
    (list inst)))

(defprop open assemble-inst-open sim-asm-function)
(defprop open ((%%i-opcode %i-op-open)) sim-asm)

(defprop tail-recursive-open assemble-inst-open sim-asm-function)
(defprop tail-recursive-open ((%%i-opcode %i-op-tail-recursive-open)) sim-asm)

(defun assemble-inst-open (sym-inst)
  (let ((inst 0) x load-time-stuff
        (regular-open-p (eq (car sym-inst) 'open))
        (seen-dest-p nil)
        )
    (dolist (clause sym-inst)
      (cond ((consp clause)
             (setq seen-dest-p t)
             (multiple-value-bind (new-inst load-stuff)
                 (parse-register-adr inst clause '%%i-dest-base '%%i-dest-offset)
               (setq inst new-inst)
               (setq load-time-stuff (append load-time-stuff load-stuff))))
            ((setq x (get clause 'sim-asm))
             (when (consp x)
               (dolist (field (get clause 'sim-asm))
                 (setq inst (dpb (eval (cadr field)) (eval (car field)) inst)))))
            (t
             (ferror nil "unknnown atom ~s" clause))))
    (cond ((and regular-open-p
                (not seen-dest-p))
           (ferror nil "open must have dest"))
          ((and (not regular-open-p)
                seen-dest-p)
           (ferror nil "tail-recursive-open doesn't have a dest")))
    (cons inst load-time-stuff)))


(defprop call-xct-next assemble-inst-call sim-asm-function)
(defprop call-xct-next ((%%i-opcode %i-op-call)) sim-asm)
(defprop tail-recursive-call-xct-next assemble-inst-call sim-asm-function)
(defprop tail-recursive-call-xct-next ((%%i-opcode %i-op-tail-recursive-call)) sim-asm)
(defprop tail-recursive-call-xct-next-indirect assemble-inst-call sim-asm-function)
(defprop tail-recursive-call-xct-next-indirect ((%%i-opcode %i-op-tail-recursive-call-indirect)) sim-asm)
(defun assemble-inst-call (sym-inst)
  (let ((inst 0) x load-time-stuff (symbolic-op (car sym-inst)))
    (dolist (clause sym-inst)
      (cond ((consp clause)
             (when (not (eq symbolic-op 'tail-recursive-call-xct-next-indirect))
               (ferror nil "??"))
             (multiple-value-bind (new-inst load-stuff)
                 (parse-register-adr inst clause '%%i-src-1-base '%%i-src-1-offset)
               (setq inst new-inst)
               (setq load-time-stuff (append load-time-stuff load-stuff))))
            ((setq x (get clause 'sim-asm))
             (when (consp x)
               (dolist (field (get clause 'sim-asm))
                 (setq inst (dpb (eval (cadr field)) (eval (car field)) inst)))))
            ((numberp clause)
             (setq inst (dpb clause %%i-jump-adr inst)))
            ((assq clause *local-symbols*)
             ;(setq load-time-stuff (append `(%%i-jump-adr (jump-target ,clause)) load-time-stuff)))
             (ferror nil "what are you trying to call that is on the *local-symbols* list?"))
            (t
             (setq load-time-stuff (append `(%%i-jump-adr (jump-target ,clause)) load-time-stuff))
             )))
    (cons inst load-time-stuff)))


(defprop return-xct-next assemble-inst-generic sim-asm-function)
(defprop return-xct-next ((%%i-opcode %i-op-return)) sim-asm)

(defun disassemble-inst (inst)
  (select (ldb %%i-opcode inst)
    (%i-op-alu (disassemble-inst-alu inst))
    (%i-op-jump (disassemble-inst-jump inst))
    (%i-op-sim (disassemble-inst-sim inst))
    (%i-op-open (disassemble-inst-open inst))
    (%i-op-tail-recursive-open (disassemble-inst-tail-recursive-open inst))
    (%i-op-call (disassemble-inst-call inst))
    (%i-op-tail-recursive-call (disassemble-inst-tail-recursive-call inst))
    (%i-op-return (disassemble-inst-return inst))
    (%i-op-store-immediate (disassemble-inst-store-immediate inst))
    (%i-op-tail-recursive-call-indirect (disassemble-inst-tail-recursive-call-indirect inst))
    (t (ferror nil "unknown opcode"))))

(defun disassemble-inst-store-immediate (original-inst)
  (let ((inst original-inst)
        sym-inst)
    (setq sym-inst
          `(store-immediate ,(unparse-reg-adr (ldb %%i-dest-base inst)
                                              (ldb %%i-dest-offset inst)
                                              (ldb %%i-immediate inst))))
    (setq inst (dpb 0 %%i-dest-base inst))
    (setq inst (dpb 0 %%i-dest-offset inst))
    (setq inst (dpb 0 %%i-immediate inst))
    (setq inst (dpb 0 %%i-opcode inst))

    (when (ldb-test %%i-halt inst)
      (setq sym-inst (append sym-inst '(halt)))
      (setq inst (dpb 0 %%i-halt inst)))

    (when (not (zerop inst))
      (ferror nil "leftover bits"))
    sym-inst))

(defun disassemble-inst-open (original-inst)
  (let* ((inst original-inst)
         (sym-inst `(open
                      ,(unparse-reg-adr (ldb %%i-dest-base inst)
                                        (ldb %%i-dest-offset inst)
                                        (ldb %%i-immediate inst)))))
    (setq inst (dpb 0 %%i-dest-base inst))
    (setq inst (dpb 0 %%i-dest-offset inst))
    (setq inst (dpb 0 %%i-immediate inst))
    (setq inst (dpb 0 %%i-opcode inst))
    (when (ldb-test %%i-halt inst)
      (setq sym-inst (append sym-inst (list 'halt)))
      (setq inst (dpb 0 %%i-halt inst)))
    (when (not (zerop inst))
      (ferror nil "leftover bits"))
    sym-inst))

(defun disassemble-inst-tail-recursive-open (inst)
  inst
  `(tail-recursive-open))

(defun disassemble-inst-call (inst)
  `(,(ecase (ldb %%i-noop-next-bit inst)
       (0 'call-xct-next)
       (1 'call))
    ,(let ((adr (ldb %%i-jump-adr inst)))
       (or (adr-to-breakpoint-name adr) adr))))

(defun disassemble-inst-tail-recursive-call (inst)
  `(,(ecase (ldb %%i-noop-next-bit inst)
       (0 'tail-recursive-call-xct-next)
       (1 'tail-recursive-call))
    ,(ldb %%i-jump-adr inst)))

(defun disassemble-inst-tail-recursive-call-indirect (inst)
  `(,(ecase (ldb %%i-noop-next-bit inst)
       (0 'tail-recursive-call-xct-next)
       (1 'tail-recursive-call))
    ,(unparse-reg-adr (ldb %%i-src-1-base inst) (ldb %%i-src-1-offset inst) (ldb %%i-immediate inst))))

(defun disassemble-inst-return (inst)
  `(,(ecase (ldb %%i-noop-next-bit inst)
       (0 'return-xct-next)
       (1 'return))
    ))


(defun disassemble-inst-sim (inst)
  `(sim ,(aref *sim-ops* (ldb %%i-immediate inst))))

(defun unparse-reg-adr (base-code offset immediate)
  (let ((result (list nil nil)))
    (select base-code
      (%i-base-active
       (setf (car result) 'active)
       (setf (cadr result) offset))
      (%i-base-open
       (setf (car result) 'open)
       (setf (cadr result) offset))
      (%i-base-return
       (cond ((= offset #o17)
              (setq result (list 'garbage)))
             (t
              (setf (car result) 'return)
              (setf (cadr result) offset))))
      (%i-base-global
       (setf (car result) 'global)
       (setf (cadr result) (+ offset (ash immediate 4))))
      (%i-base-func
       (setf (car result) 'func)
       (setf (cadr result) (select offset
                             (%func-vma 'vma)
                             (%func-vma-start-write 'vma-start-write)
                             (%func-vma-start-read 'vma-start-read)
                             (%func-md 'md)
                             (%func-return 'return)
                             (%func-instruction-counter 'instruction-counter)
                             (t
                              (ferror nil "unknown functional register")))))
      (t
       (ferror nil "unknown base code")))
    result))


(defun disassemble-inst-alu (original-inst)
  (let ((result (make-alu-inst))
        (inst original-inst))
    (setf (alu-inst-flag result) 'alu)
    (setf (alu-inst-arrow result) '<-)
    (setq inst (dpb 0 %%i-opcode inst))
    (setf (alu-inst-dest result)
          (unparse-reg-adr (ldb %%i-dest-base inst)
                           (ldb %%i-dest-offset inst)
                           (ldb %%i-immediate inst)))
    (setq inst (dpb 0 %%i-dest-base inst))
    (setq inst (dpb 0 %%i-dest-offset inst))

    (setf (alu-inst-s1 result)
          (unparse-reg-adr (ldb %%i-src-1-base inst)
                           (ldb %%i-src-1-offset inst)
                           (ldb %%i-immediate inst)))
    (setq inst (dpb 0 %%i-src-1-base inst))
    (setq inst (dpb 0 %%i-src-1-offset inst))

    (setf (alu-inst-s2 result)
          (unparse-reg-adr (ldb %%i-src-2-base inst)
                           (ldb %%i-src-2-offset inst)
                           (ldb %%i-immediate inst)))
    (setq inst (dpb 0 %%i-src-2-base inst))
    (setq inst (dpb 0 %%i-src-2-offset inst))
    (setq inst (dpb 0 %%i-immediate inst))

    (setf (alu-inst-aluop result)
          (select (ldb %%i-aluf inst)
            (0 'setz)
            (lam:lam-alu-add 'add)
            (lam:lam-alu-setm 'set1)
            (lam:lam-alu-m-a-1 'm-a-1)
            (lam:lam-alu-sub 'sub)
            (lam:lam-alu-ior 'or)
            (lam:lam-alu-and 'and)
            (lam:lam-alu-m+a+1 'l+r+1)
            (t (ferror nil "unknown alu function"))))
    (setq inst (dpb 0 %%i-aluf inst))

    (when (ldb-test %%i-uses-alu inst)
      (setq result (append result (list 'uses-alu)))
      (setq inst (dpb 0 %%i-uses-alu inst)))
    (when (ldb-test %%i-halt inst)
      (setq result (append result (list 'halt)))
      (setq inst (dpb 0 %%i-halt inst)))
    (when (not (zerop inst))
      (ferror nil "leftover bits"))
    result))

(defun disassemble-inst-jump (original-inst)
  (let ((result (make-jump-inst))
        (inst original-inst))
    (setq inst (dpb 0 %%i-opcode inst))
    (ecase (ldb %%i-noop-next-bit inst)
      (0 (setf (jump-inst-type result) 'jump-xct-next))
      (1 (setf (jump-inst-type result) 'jump)))
    (setq inst (dpb 0 %%i-noop-next-bit inst))
    (setf (jump-inst-cond result)
          (select (ldb %%i-jump-cond inst)
            (%i-jump-cond-unc 'always)
            (%i-jump-cond-less-than 'less-than)
            (%i-jump-cond-equal 'equal)
            (%i-jump-cond-not-equal 'not-equal)
            (%i-jump-cond-greater-than 'greater-than)
            (%i-jump-cond-greater-or-equal 'greater-or-equal)
            (t (ferror nil "unknown jump cond"))))
    (setq inst (dpb 0 %%i-jump-cond inst))
    (let ((adr (ldb %%i-jump-adr inst)))
      (let ((name (adr-to-breakpoint-name adr)))
        (cond ((null name)
               (setf (jump-inst-target result) (ldb %%i-jump-adr inst)))
              (t
               (setf (jump-inst-target result) name)))))
    (setq inst (dpb 0 %%i-jump-adr inst))
    (when (not (zerop inst))
      (ferror nil "leftover bits"))
    result))



(defun assemble-program (program)
  (let ((*local-symbols* nil)
        (last-inst-was-return nil)
        )
    (loop for sym-inst in program
          when (symbolp sym-inst)
          do (push (cons sym-inst :unknown) *local-symbols*))
    (loop for sym-inst in program
          collect (cond ((consp sym-inst)
                         (when (and last-inst-was-return
                                    (not (member '(func return) sym-inst :test 'equal)))
                           (ferror nil "return instructions must be followed by dest (FUNC RETURN)"))
                         (setq last-inst-was-return (eq (car sym-inst) 'return-xct-next))
                         (assemble-inst sym-inst))
                        (t sym-inst)))))

(defmacro define-asm (name &rest form)
  (declare (arglist name arglist &body body))
  `(define-asm-1 ',name ',form))

(defun define-asm-1 (name form)
  (when (not (symbolp name))
    (ferror nil "name must be symbol"))
  (let ((lambda-exp (si:process-defun-body name form t))
        documentation
        arglist
        declarations
        body
        )
    ;;now we have (named-lambda (foo (documentation "foobar")) (args) (declare (...) (...)) body)
    ;;the declare may be absent
    (setq documentation (cadr (assq 'si:documentation (si:debugging-info lambda-exp))))
    (setq arglist (third lambda-exp))
    (setq body (cdddr lambda-exp))
    (when (eq (caar body) 'declare)
      (setq declarations (cdr (car body)))
      (pop body))

    (putprop name (assemble-program body) 'sim-program)))


(defvar *constants* (make-array 16.))
(defvar *constants-frame-base* 1)

(defun find-or-make-constant (val)
  (setq val (eval val))
  (cond ((eq val t)
         (setq val (dpb dtp-symbol %%q-data-type 5)))
        ((eq val nil)
         (setq val (dpb dtp-symbol %%q-data-type 0))))
  (do ((index 0 (1+ index))                     ;don't use 0
       first-free)
      ((= index (array-length *constants*))
       (when (null first-free)
         (ferror nil "out of constant slots"))
       (aset val *constants* first-free)
       (+ (* *constants-frame-base* 16.)
          first-free))
    (let ((this-val (aref *constants* index)))
      (when (and (integerp this-val)
                 (= this-val val))
        (return (+ (* *constants-frame-base* 16.)
                   index)))
      (when (and (null this-val)
                 (null first-free))
        (setq first-free index)))))

(defun install-constants ()
  (do ((index 0 (1+ index))
       (register (* *constants-frame-base* 16.) (1+ register)))
      ((= index (array-length *constants*)))
    (let ((val (aref *constants* index)))
      (when val
        (send *proc* :write-frames register val)))))


(defun count-instructions (function)
  (let ((code (get function 'sim-program)))
    (when (null code)
      (ferror nil "no code"))
    (do ((adr 0)
         (inst-list code (cdr inst-list)))
        ((null inst-list)
         adr)
      (when (consp (car inst-list))
        (incf adr)))))

(defun d (f)
  (grind-top-level (get f 'sim-program)))

(defun load-resolve-immediate-data (val)
  (cond ((consp val)
         (ecase (car val)
           (value-cell
            (cond ((eq (cadr val) nil)
                   (dpb dtp-symbol %%q-data-type 0))
                  (t
                   (ferror nil "don't know any symbols but nil"))))
           (function
            (let ((adr (symbol-lookup (cadr val))))
              (when (null adr)
                (ferror nil "function ~s is not defined" (cadr val)))
              adr))
           (quote
            (>whole-q (>intern (string (cadr val)))))
           ))
        ((integerp val)
         val)
        (t
         (ferror nil "unknown immediate ~s" val))))


(defun store-function-into-main-memory (function starting-adr &aux jump-addresses)
  (labels ((load-time-update (inst field val)
                             (case field
                               (immediate-data
                                (load-resolve-immediate-data val))
                               (t
                                (ecase (car val)
                                  ((jump-target local-jump-target)
                                   (let ((possible-local (assq (cadr val) jump-addresses)))
                                     (cond ((null possible-local)
                                            (let ((func (symbol-lookup (cadr val))))
                                              (when (null func)
                                                (ferror nil "unknown jump target ~s" (cadr val)))
                                              (dpb func (eval field) inst)))
                                           (t
                                            (dpb (cdr possible-local) (eval field) inst)))))
                                  (constant-frame
                                   (let ((constant-adr (find-or-make-constant (cadr val))))
                                     (let ((frame (ldb (byte 8 4) constant-adr)))
                                       (when (and (not (zerop (ldb %%i-immediate inst)))
                                                  (not (= (ldb %%i-immediate inst) frame)))
                                         (ferror nil "two different global frames in same inst"))
                                       (dpb frame %%i-immediate inst))))
                                  (constant-offset
                                   (let ((constant-adr (find-or-make-constant (cadr val))))
                                     (dpb constant-adr (eval field) inst)))

                                  )))))
    (when (null (get function 'sim-program))
      (ferror nil "no program"))
    (do ((adr starting-adr)
         (code (get function 'sim-program) (cdr code)))
        ((null code)
         (push (cons '|end| adr) jump-addresses))
      (cond ((consp (car code))
             (incf adr))
            (t
             (push (cons (car code) adr) jump-addresses))))
    (do ((adr starting-adr)
         numeric-inst
         (inst-list (get function 'sim-program) (cdr inst-list)))
        ((null inst-list))
      (when (consp (car inst-list))
        (setq numeric-inst (caar inst-list))
        (do ((load-time-stuff (cdar inst-list) (cddr load-time-stuff)))
            ((null load-time-stuff))
          (setq numeric-inst (load-time-update numeric-inst (car load-time-stuff) (cadr load-time-stuff))))
        (send *proc* :write-main-memory adr numeric-inst)
        (incf adr)))
    (cdr (assq '|end| jump-addresses))))
